home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Amiga Plus 1995 #5 & #6
/
Amiga Plus CD - 1995 - No. 5 and 6.iso
/
pd
/
netz
/
ums
/
ums-beta
/
rexxdossupport
/
txt
/
rexxdossupport.mod
next >
Wrap
Text File
|
1995-04-01
|
39KB
|
1,222 lines
(*(***********************************************************************
:Program. rexxdossupport.mod
:Contents. access to V37+ Dos.library functions from within ARexx
:Author. hartmtut Goebel [hG]
:Address. Aufseßplatz 5, D-90459 Nürnberg
:Address. UseNet: hartmut@oberon.nbg.sub.org
:Copyright. Copyright © 1993 by hartmtut Goebel
:Language. Oberon-2
:Translator. Amiga Oberon 3.11
:Imports. Printf (Volker Rudolph), RxLibsSupport [hG]
:Version. $VER: rexxdossupport.mod 2.3 (1.4.95) Copyright © 1994,1995 by hartmtut Goebel
(* $StackChk- $NilChk- $RangeChk- $CaseChk- $OvflChk- $ReturnChk- $ClearVars- *)
(****** rexxdossupport.library/--history-- **********************
*
* 2.3 01 Apr 1995
* · fixed problem with synonyms: foo=bar lead to illegal
* variable named 'FOO=BAR'. Now allways th first synonym is
* taken as var-name.
*
* 2.2 18 Jul 1994
* · Shame on me! library names must be lowercase
* · Some more notes in documentation
* 2.1 03 Jun 1994
* · removed curious bug in ReadArgs() (uninitialized var,
* introduced in V2.0)
* 2.0 07 May 1994 (never released)
* · stronger check for present args to avoid NIL-Traps
* · new functions: Delete(), Rename(), MakeDir(),
* SetComment(), SetProtection()
* 1.4 01 Feb 1994
* · only significant part of parsed pattern is copied
* into the ARexx Argstring
* 1.3 23 Jan 1994
* · uses module RxLibsSupport [hG]
* 1.2 18 Jan 1994
* · finished dokumentation
* · UnsetVar() - like shell commnad - renamed to
* DeleteVar() - like in dos.library
* · SetVar() no longer accepts option "Binary"
* 1.1 16 Jan 1994
* initial release
*
*******
(****** rexxdossupport.library/--Disclaimer-- **********************
*
*Disclaimer
*----------
*
* Permission is granted to make and distribute verbatim copies of this
*manual provided the copyright notice and this permission notice are
*preserved on all copies.
*
*COPYRIGHT
*
* Copyright (C) 1994 by hartmut Goebel
*
* No program, document, data file or source code from this software
*package, neither in whole nor in part, may be included or used in other
*software packages unless it is authorized by a written permission from
*the author.
*
*
*NO WARRANTY
*
* There is no warranty for this software package. Although the author
*has tried to prevent errors, he can't guarantee that the software package
*described in this document is 100% reliable. You are therefore using this
*material at your own risk. The author cannot be made responsible for any
*damage which is caused by using this software package.
*
*
*DISTRIBUTION
*
* This software package is freely distributable. It may be put on any
*media which is used for the distribution of free software, like Public
*Domain disk collections, CDROMs, FTP servers or bulletin board systems.
*
* In order to ensure the integrity of this software package,
*distributors should use the original archive file rexxdossupport2_2.lha.
*The author cannot be made responsible if this software package has
*become unusable due to modifications of the archive contents or of
*the archive file itself.
*
* There is no limit on the costs of the distribution, e.g. for the
*media, like floppy disks, streamer tapes or compact disks, or the process
*of duplicating. Such limits have been proven to be harmful to the idea of
*freely distributable software, e.g. instead of reducing the price of the
*floppy disk below the limit, the software was simply removed from the
*master disk.
*
* Although the author does not impose any limit on the distribution of
*this software package, he would like to express his personal opinions on
*this matter:
*
* * This software package should be made available to everyone free of
* charge whenever it is possible.
*
* * If you have acquired this software package under normal conditions
* from a Public Domain dealer on a floppy disk at a price higher than
* 5DM or US $5, then you have definitely paid too much. Please don't
* support this improper profit making any longer and switch to a
* cheaper source as soon as possible.
*
*
*USAGE RESTRICTIONS
*
* No program, document, data file or source code from this software
*package, neither in whole nor in part, may be used on any machine which
*is used
*
* * for the research, development, construction, testing or production
* of weapons or other military applications. This also includes any
* machine which is used in the education for any of the above
* mentioned purposes.
*
* * by people who accept, support or use violence against other people,
* e.g. citizens from foreign countries.
*
*********)*)*)*)
(****** rexxdossupport.library/--background-- *******************
*
* rexxdossupport.library 2.2
* ==========================
*
* Copyright (C) 1994 by hartmut Goebel
*
*
* After programming ARexx script for quite a while, I missed some
* function found in dos.library -- especially access to
* environment variables and the comfortable argument parsing. Since
* there seamed to be no ARexx function library which implements
* this functions, I decited to write my own. And here it is.
*
* This are the functions handled by this library.
* · ReadArgs()
* · GetVar(), SetVar(), DeleteVar()
* · ParsePattern(), MatchPattern() - even case-insensitive
* · Fault()
*
* new functions for version 2.1
* · Delete(), Rename(), MakeDir()
* · SetComment(), SetProtection()
*
* Enjoy it!
* +++hartmut
*
*********)
(****** rexxdossupport.library/--installation-- *******************
*
* To use rexxdossupport.library, just copy is to yout LIBS:
* directory. That's all.
*
* The LVO for the ARexx-Dispatcher is -30.
* NB: it's the only LVO for this library :-)
*
* So, in every ARexx-Script you want to use rexxdossupport.library,
* insert
*
* call addlib("rexxdossupport.library",0,-30,2)
*
* somewhere before the first call to one of the routines
* implemented in this library.
* Since ARexx does not check whether the lib can be opened but only
* inserts the name into a list, the result value from addlib() can
* be ignored in most cases. The value would be interesting to check
* if the added note will require the same library version, but I
* don't know how to find this out.
*
*********)
MODULE rexxdossupport;
(* $StackChk- $ClearVars- *)
IMPORT
d := Dos,
e := Exec,
str := Strings,
pf := Printf,
ol := OberonLib,
rx := Rexx,
rxs := RexxSysLib,
rvi := RVI,
rls := RxLibsSupport,
y := SYSTEM;
CONST
versionString = "$VER: rexxdossupport 2.3 (1.4.95) Copyright © 1994,1995 by hartmtut Goebel";
progNotFound = rls.progNotFound;
noMemory = rls.noMemory;
badNumArgs = rls.badNumArgs;
stringTooLong= rx.err10009;
funcErr = rx.err10012;
invalidArg = rx.err10018;
nestingLevel = rx.err10043;
invalidTemplate = rx.err10037;
errorReturnFromFunc = rx.err10012;
strTRUE = rls.strTRUE;
strFALSE = rls.strFALSE;
PROCEDURE ^ GetVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ SetVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ DeleteVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ MatchPattern (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ ParsePattern (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ Fault (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ ReadArgs (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
(* new for V2.0 *)
PROCEDURE ^ Delete (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ Rename (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ MakeDir (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ SetComment (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
PROCEDURE ^ SetProtection (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
CONST
numFunctions = 12;
TYPE
FunctionList = ARRAY numFunctions OF rls.FunctionListEntry;
CONST
functionList = FunctionList(
y.ADR("GetVar"),1,3,GetVar,
y.ADR("SetVar"),2,3,SetVar,
y.ADR("DeleteVar"),1,2,DeleteVar,
y.ADR("MatchPattern"),2,4,MatchPattern,
y.ADR("ParsePattern"),1,2,ParsePattern,
y.ADR("Fault"),1,2,Fault,
y.ADR("ReadArgs"),2,3,ReadArgs,
y.ADR("Delete"),1,1,Delete,
y.ADR("Rename"),2,2,Rename,
y.ADR("SetComment"),2,2,SetComment,
y.ADR("SetProtection"),2,2,SetProtection,
y.ADR("MakeDir"),1,1,MakeDir
);
(* ---------------------------------------------------------------- *)
(****** rexxdossupport.library/ReadArgs ***************
*
* NAME
* ReadArgs -- Parse argument string using Dos/ReadArgs()
*
* SYNOPSIS
* okay = ReadArgs( arguments, template, [stem] )
*
* FUNCTION
* Parses an argument string according to a template. See
* dos.library/ReadArgs() for details and describtion of the
* template.
*
* This function supports the following template options:
*
* /S - Switch. Resulting variable will be either true (1) or
* false (0).
* /N - Number.
* /M - Multiple strings. See below for further information.
*
* /K - Keyword. }
* /A - Required. } handled by dos
* /F - Rest of line. }
*
* /T (toggle) is not supported, since handling this would be a
* large turnover with small profit.
*
* INPUTS
* arguments - the string to be parsed
* template - dos.library/ReadArgs()-style like template
* stem - stem prefix for resulting variables (optional)
*
* RESULT
* okay - boolean value indicating success.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* For each item in the template which has a corresponding
* argument, a Rexx variable will be created. The variable's
* name is the item's name prefixed by the stem name (if given).
*
* Items with option /M will result in a stem variable with a
* .COUNT node containing the number of elements. If no fitting
* arguments is passed, .COUNT will be zero.
* The entries will be in stem nodes .0 to .n (where n is
* .COUNT-1).
*
* EXAMPLE
* /* ReadArgsExample.rexx */
* /* AddLib() here */
*
* parse arg args /* get the arguments w/o ARexx-Parsing */
*
* template = "Files/M,Method/K,MinSize/K/N,Test/S"
*
* /* set defaults */
* Method = "NUKE"; MinSize = 512;
*
* /* no stem given: results are assigned to simple variables */
*
* if ReadArgs(args,template) then
* say 'Method =' method ' MinSize =' MinSize ' Test =' test
* do i = 0 by 1 for file.count
* say name.1
* end
*
* /* stem given: results are assigned to stem variable */
* /* since the default values are set as non-stem variables,
* * they are not overwritten by the following call even if
* * given
* */
*
* if ReadArgs(input,template,"args.") then
* say 'Method =' args.method ' MinSize =' args.MinSize ' Test =' args.test
* do i = 0 by 1 for args.file.count
* say args.name.1
* end
*
* SEE ALSO
* Fault(), dos.library/ReadArgs()
*
***********************)
PROCEDURE ReadArgs (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
TYPE ArgsArray = UNTRACED POINTER TO ARRAY d.maxMultiArgs+1 OF LONGINT;
PROCEDURE CreateSTEM (msg: rx.RexxMsgPtr;
template: e.LSTRPTR;
resarray: ArgsArray;
stembase: e.STRPTR): INTEGER;
VAR
synonym, result, rs, rb, t, wordCnt: INTEGER;
opts, optn, optm: BOOLEAN;
longbuff: rls.ConvertLongBuffer;
resb: ARRAY 512 OF CHAR;
PROCEDURE GetValue (value: LONGINT): INTEGER;
VAR
string: e.LSTRPTR;
BEGIN
IF opts THEN
IF value = d.DOSFALSE THEN string := y.ADR(strFALSE);
ELSE string := y.ADR(strTRUE); END;
ELSIF optn THEN (* numerisch *)
pf.SPrintf1(longbuff, "%ld", y.VAL(ArgsArray,value)[0]);
string := y.ADR(longbuff);
ELSE (* string *)
string := y.VAL(e.LSTRPTR,value);
END; (*$RangeChk-*)
RETURN SHORT(rvi.SetRexxVar(msg,resb,string^,str.Length(string^))); (*$RangeChk=*)
END GetValue;
PROCEDURE CreateResultList(value: ArgsArray): INTEGER;
VAR
index: INTEGER;
tt: e.STRPTR;
result: INTEGER;
BEGIN
tt := y.ADR(resb[t]);
index := 0;
IF value # NIL THEN
WHILE value[index] # NIL DO
pf.SPrintf1( tt^, ".%ld", index); (* Index an den Stem-Namen anhängen *)
result := GetValue(value[index]);
IF result # 0 THEN RETURN result; END;
INC(index);
END;
END;
tt^ := ".COUNT"; (* Die Count-Node ausfüllen *)
pf.SPrintf1( longbuff, "%ld", index ); (*$RangeChk-*)
RETURN SHORT(rvi.SetRexxVar(msg,resb,longbuff,str.Length(longbuff))); (*$RangeChk=*)
END CreateResultList;
BEGIN
wordCnt := 0; result := rx.ok;
IF stembase # NIL THEN (* Präfix einbauen *)
COPY(stembase^,resb); rb := SHORT(str.Length(resb));
str.Upper(resb);
ELSE
resb := ""; rb := 0;
END;
rs := 0;
(* Liste aufbauen *)
WHILE template[rs] # CHR(0) DO
t := rb; optn := FALSE; optm := FALSE; opts := FALSE; synonym := -1;
LOOP
CASE template[rs] OF
| CHR(0): EXIT;
| ",": INC(rs); EXIT;
| "=": synonym := t;
| "/":
INC(rs);
CASE CAP(template[rs]) OF
| "N": optn := TRUE;
| "M": optm := TRUE;
| "S": opts := TRUE;
ELSE END;
ELSE
resb[t] := CAP(template[rs]); INC(t); (* Resultatnamen kopieren *)
END;
INC(rs);
END;
IF synonym >= 0 THEN t := synonym; END;
resb[t] := CHR(0);
IF opts THEN
optm := FALSE; optn := FALSE; END;
(* hier ist nun der Basisname der Stem-Variable in resb,
* und t zeigt in resb auf die Stelle, an der nun ggf. die
* Stem-Erweiterungen (.COUNT, .0 - .n) angehängt werden
*)
IF optm THEN (* /M war im Namen, also Liste *)
result := CreateResultList(y.VAL(ArgsArray,resarray[wordCnt]));
ELSE (* keine Liste *)
IF opts OR (resarray[wordCnt] # NIL) THEN
result := GetValue(resarray[wordCnt]);
END;
END;
IF result # rx.ok THEN RETURN result; END;
INC(wordCnt);
END;
RETURN result;
END CreateSTEM;
CONST
rdArgsDefault = d.RDArgs(NIL,0,0, 0, NIL,0,NIL,LONGSET{d.noPrompt});
argInput = 1; argTemplate = 2; argStem = 3;
VAR
argv: UNTRACED POINTER TO d.ArgsStruct;
arguments, rdArgs: d.RDArgsPtr;
pos, numArgs: LONGINT;
retval: INTEGER;
input: e.LSTRPTR;
BEGIN (* ReadArgs *)
IF ~ rls.ArgsPresent(msg,1,2) THEN RETURN invalidArg; END;
IF (rx.ActionArg(msg.action) < argStem) THEN msg.args[argStem] := NIL; END;
retval := noMemory;
pos := rxs.LengthArgstring(msg.args[argInput]);
input := rxs.CreateArgstring(msg.args[argInput]^,pos+1);
IF input # NIL THEN
input[pos] := CHR(0AH); (* LineFeed, needed for ReadArgs() *)
numArgs := 0; pos := -1;
REPEAT
INC(numArgs);
pos := str.OccursPos(msg.args[argTemplate]^,",",pos+1);
UNTIL pos < 0;
rdArgs := d.AllocDosObject(d.rdArgs,NIL);
IF rdArgs # NIL THEN
ol.Allocate(argv,numArgs*SIZE(e.APTR));
IF argv # NIL THEN
rdArgs^ := rdArgsDefault;
rdArgs.source.buffer := y.ADR(input^);
rdArgs.source.length := rxs.LengthArgstring(input);
arguments := d.ReadArgs(msg.args[argTemplate]^,argv^,rdArgs);
IF arguments = NIL THEN
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
ELSE
resultStr := rxs.CreateArgstring(strTRUE,1);
retval := CreateSTEM(msg, msg.args[argTemplate],
y.VAL(ArgsArray,argv),
y.VAL(e.STRPTR,msg.args[argStem]));
d.FreeArgs(arguments);
END;
IF resultStr = NIL THEN retval := noMemory; END;
DISPOSE(argv);
END;
d.FreeDosObject(d.rdArgs,rdArgs);
END;
END;
RETURN retval;
END ReadArgs;
(* ---------------------------------------------------------------- *)
PROCEDURE CheckBinaryVar (msg: rx.RexxMsgPtr;
argNum: INTEGER;
VAR flags: LONGSET): BOOLEAN;
VAR
isBin: BOOLEAN;
BEGIN
IF rls.IsValidArg(msg,argNum,"B",isBin) THEN
IF isBin THEN
flags := flags + LONGSET{d.binaryVar,d.dontNullTerm};
END;
RETURN TRUE;
ELSE
RETURN FALSE;
END;
END CheckBinaryVar;
PROCEDURE CheckLocalGlobal (msg: rx.RexxMsgPtr;
argNum: INTEGER;
VAR flags: LONGSET): BOOLEAN;
BEGIN
IF (rx.ActionArg(msg.action) >= argNum) & (msg.args[argNum] # NIL) THEN
CASE CAP(msg.args[argNum][0]) OF
|"G": INCL(flags,d.globalOnly);
|"L": INCL(flags,d.localOnly);
ELSE
RETURN FALSE;
END;
END;
RETURN TRUE;
END CheckLocalGlobal;
(****** rexxdossupport.library/GetVar *******************
*
* NAME
* GetVar -- Returns the value of a local or global variable
*
* SYNOPSIS
* string = GetVar( name, ["Local" | "Global"], ["Binary"] )
*
* FUNCTION
* Gets the value of a local or environment variable. It is advised to
* only use ASCII strings inside variables, but not required. This stops
* putting characters into the destination when a \n is hit, unless
* "Binary" is specified. (The \n is not stored in the buffer.)
*
* INPUTS
* name - variable name.
* "Global" - tries to get a global env variable.
* "Local" - tries to get a local variable (see note below).
* "Binary" - don't stop at \n
* in this mode the string returned is not null terminated
*
* The default is to try to get a local variable first,
* then to try to get a global environment variable.
*
* RESULT
* string - contents of the variable
*
* RC (rexx variable) - 5 when variable does not exist,
* 0 otherwise
*
* EXAMPLE
* /* */
* username = GetVar("username")
* if RC = 5 then
* say "Variable 'username' is not set"
* else
* say "Variable 'username' is" username
*
* NOTES
* contents may be max. 512 char.
*
* Since ARexx spawn a new process of each script -- even if
* started from Shell -- option "Local" may not work as supposed.
*
* BUGS
* Due to a bug in dos.library, binary global vars will be null
* terminated in V37, V38.
*
* SEE ALSO
* SetVar(), DeleteVar(), dos.library/GetVar()
*
**********************)
PROCEDURE GetVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
flags: LONGSET;
len: LONGINT;
res: INTEGER;
buffer: ARRAY 512 OF CHAR;
CONST
argName = 1; argLocGlob = 2; argBinary = 3;
BEGIN
flags := LONGSET{};
IF ~ CheckLocalGlobal(msg,argLocGlob,flags)
OR ~ CheckBinaryVar(msg,argBinary,flags)
OR (msg.args[argName] = NIL) THEN
RETURN invalidArg;
END;
len := d.GetVar(msg.args[argName]^,buffer,SIZE(buffer),flags);
IF len < 0 THEN
RETURN rls.SetRC5(msg);
END;
IF (len > SIZE(buffer)-1) & (len # d.IoErr()) THEN
RETURN stringTooLong;
END;
resultStr := rxs.CreateArgstring(buffer,len);
IF resultStr = NIL THEN RETURN noMemory; END;
RETURN rls.SetRC0(msg);
END GetVar;
(****** rexxdossupport.library/SetVar *******************
*
* NAME
* SetVar -- Sets a local or environment variable
*
* SYNOPSIS@{ub}
* success = SetVar( name, ["Local" | "Global"] )
*
* FUNCTION
* Sets a local or environment variable. It is advised to only use
* ASCII strings inside variables, but not required.
*
* INPUTS
* name - variable name.
* "Global" - tries to get a global env variable.
* "Local" - tries to get a local variable (see note below).
*
* The default is to set a local environment variable.
*
* RESULT
* success - If non-zero, the variable was sucessfully set, FALSE
* indicates failure.
*
* NOTES
* Since ARexx spawn a new process of each script -- even if
* started from Shell -- option "Local" may not work as supposed.
*
* SEE ALSO
* GetVar(), DeleteVar(), dos.library/SetVar()
*
**************************)
PROCEDURE SetVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
flags: LONGSET;
CONST
argName = 1; argContents = 2; argLocGlob = 3;
BEGIN
flags := LONGSET{};
IF ~ CheckLocalGlobal(msg,argLocGlob,flags)
OR (msg.args[argName] = NIL) THEN
RETURN invalidArg;
END;
IF d.SetVar(msg.args[argName]^,msg.args[argContents]^,
rxs.LengthArgstring(msg.args[argContents]),flags) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
END;
IF resultStr = NIL THEN RETURN noMemory; END;
RETURN rx.ok;
END SetVar;
(****** rexxdossupport.library/DeleteVar *******************
*
* NAME
* DeleteVar -- Deletes a local or environment variable
*
* SYNOPSIS
* success = DeleteVar( name, [ "Local" | "Global" ] )
*
* FUNCTION
* Deletes a local or environment variable.
*
* INPUTS
* name - variable name. Note variable names follow
* filesystem syntax and semantics.
* "Global" - tries to get a global env variable.
* "Local" - tries to get a local variable (see note below).
*
* The default is to delete a local variable if found, otherwise
* a global environment variable if found.
*
* RESULT
* success - If TRUE, the variable was sucessfully deleted,
* FALSE indicates failure.
*
* NOTES
* Since ARexx spawn a new process of each script -- even if
* started from Shell -- option "Local" may not work as supposed.
*
* SEE ALSO
* GetVar(), SetVar(), dos.library/DeleteVar()
*
***********************)
PROCEDURE DeleteVar (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
flags: LONGSET;
CONST
argName = 1; argLocGlob = 2;
BEGIN
flags := LONGSET{};
IF ~ CheckLocalGlobal(msg,argLocGlob,flags)
OR (msg.args[argName] = NIL) THEN
RETURN invalidArg;
END;
IF d.DeleteVar(msg.args[argName]^,flags) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
END;
IF resultStr = NIL THEN RETURN noMemory; END;
RETURN rx.ok;
END DeleteVar;
(* ---------------------------------------------------------------- *)
(****** rexxdossupport.library/Fault *******************
*
* NAME
* Fault -- Returns the text associated with a DOS error code
*
* SYNOPSIS
* string = Fault( code, header )
*
* FUNCTION
* This routine obtains the error message text for the given
* error code. The header is prepended to the text of the error
* message, followed by a colon. By convention, error messages
* should be no longer than 80 characters, and preferably no
* more than 60.
*
* The value returned by IoErr() (not available in this library)
* is set to the code passed in. If there is no message for the
* error code, the message will be "Error code <number>\n".
*
* The string will be empty if the code passed in was 0.
*
* INPUTS
* code - Error code
* header - header to output before error text
*
* RESULT
* string - error massage as described above.
*
* RC (rexx variable) - 5 when error message is empty
* 0 otherwise
*
* BUGS
* I've been told that this function returns only an empty sting.
* Since nobody gave me further information, I can't fix it.
*
* SEE ALSO
* dos.library/Fault(), dos.library/IoErr()
*
*****************************)
PROCEDURE Fault (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
CONST
argNumber = 1; argHeader = 2;
VAR
errCode, len: LONGINT;
retval: INTEGER;
buffer: ARRAY 512 OF CHAR; (* should be enough *)
BEGIN
IF (msg.args[argNumber] = NIL) THEN RETURN invalidArg; END;
retval := rx.ok;
IF (rx.ActionArg(msg.action) < argHeader) THEN
msg.args[argHeader] := NIL; END;
len := d.StrToLong(msg.args[argNumber]^, errCode);
IF len # str.Length(msg.args[argNumber]^) THEN
RETURN invalidArg; END;
(* $NilChk- avoid trapping msg.args[argHeader]^ *)
len := d.Fault(errCode, msg.args[argHeader]^, buffer, SIZE(buffer));
(* $NilChk= *)
IF len = 0 THEN
retval := rls.SetRC5(msg);
ELSE
retval := rls.SetRC0(msg);
resultStr := rxs.CreateArgstring(buffer,str.Length(buffer));
IF resultStr = NIL THEN RETURN noMemory; END;
END;
RETURN retval
END Fault;
(* ---------------------------------------------------------------- *)
(****** rexxdossupport.library/MatchPattern *******************
*
* NAME
* MatchPattern -- Checks for a pattern match with a string
*
* SYNOPSIS
* match = MatchPattern(pattern, string, ["Nocase"], ["Parsed"] )
*
* FUNCTION
* Checks for a pattern match with a string.
* This routine is case-sensitive by default. Use option
* "NoCase" for case-insensitve matching.
*
* Use option "Parsed" to indicate that pattern has already been
* tokenized using ParsePattern(). Make sure to use or use not
* "NoCase" for both function.
*
* INPUTS
* pattern - pattern string to match
* string - string to match against given pattern
* "Nocase" - match should be case-insensitve
* "Parsed" - pattern has already been parsed using ParsePattern()
*
* RESULT
* match - success or failure of pattern match.
*
* SEE ALSO
* ParsePattern(), dos.library/MatchPattern(),
* dos.library/MatchPatternNoCase()
*
***********************)
PROCEDURE MatchPattern (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
buffer: e.LSTRPTR;
res, noCase, isParsed: BOOLEAN;
bufferLen: LONGINT;
CONST
argPattern = 1; argInput = 2; argNoCase = 3; argIsParsed = 4;
BEGIN
IF ~ rls.IsValidArg(msg,argNoCase,"N",noCase)
OR ~ rls.IsValidArg(msg,argIsParsed,"P",isParsed)
OR ~ rls.ArgsPresent(msg,argPattern,argInput) THEN
RETURN invalidArg; END;
IF isParsed THEN
buffer := msg.args[argPattern];
res := TRUE;
ELSE
bufferLen := 2 * str.Length(msg.args[argPattern]^) +2;
ol.Allocate(buffer,bufferLen);
IF buffer = NIL THEN
RETURN noMemory;
END;
IF noCase THEN
res := (d.ParsePatternNoCase(msg.args[argPattern]^,buffer^,bufferLen) >= 0);
ELSE
res := (d.ParsePattern(msg.args[argPattern]^,buffer^,bufferLen) >= 0);
END;
IF ~ res THEN
DISPOSE(buffer);
RETURN invalidTemplate;
END;
END;
IF noCase THEN res := d.MatchPatternNoCase(buffer^,msg.args[argInput]^);
ELSE res := d.MatchPattern(buffer^,msg.args[argInput]^); END;
IF ~ isParsed THEN DISPOSE(buffer); END;
IF ~ res THEN
IF d.IoErr() = 0 THEN
resultStr := rxs.CreateArgstring(strFALSE,1);
IF resultStr = NIL THEN RETURN noMemory; END;
RETURN rx.ok;
ELSE
RETURN nestingLevel;
END;
ELSE
resultStr := rxs.CreateArgstring(strTRUE,1);
IF resultStr = NIL THEN RETURN noMemory; END;
RETURN rx.ok;
END;
END MatchPattern;
(****** rexxdossupport.library/ParsePattern *******************
*
* NAME
* ParsePattern -- Create a tokenized string for MatchPattern()
*
* SYNOPSIS
* token = ParsePattern( pattern, ["NoCase"] )
*
* FUNCTION
* Tokenizes a pattern, for use by MatchPattern(). Also indicates
* if there are any wildcards in the pattern (i.e. whether it might match
* more than one item).
*
* For a description of the wildcards, see dos.library/ParsePattern().
*
* INPUTS
* pattern - unparsed wildcard string to search for.
*
* RESULT
* token - output string, tokenized version of input.
*
* RC (rexx variable) - 5 when does not contain wildcards
* 0 otherwise
*
* BUGS
* Since is't not clear wether the resulting token may contain
* null charakters, the returned string is always
* 2 * Length(pattern) + 2 bytes long.
*
* SEE ALSO
* ParsePattern(), dos.library/ParsePattern(),
* dos.library/ParsePatternNoCase()
*
*********************)
PROCEDURE ParsePattern (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
result: INTEGER;
noCase: BOOLEAN;
buffer: e.LSTRPTR;
bufferLen: LONGINT;
CONST
argPattern = 1; argNoCase = 2;
BEGIN
IF ~ rls.IsValidArg(msg,argNoCase,"N",noCase)
OR (msg.args[argPattern] = NIL) THEN
RETURN invalidArg; END;
bufferLen := 2 * str.Length(msg.args[argPattern]^) +2;
ol.Allocate(buffer,bufferLen);
IF buffer = NIL THEN
RETURN noMemory;
END;
IF noCase THEN
result := d.ParsePatternNoCase(msg.args[argPattern]^,buffer^,bufferLen)
ELSE
result := d.ParsePattern(msg.args[argPattern]^,buffer^,bufferLen);
END;
IF result < 0 THEN
result := invalidTemplate;
ELSE
resultStr := rxs.CreateArgstring(buffer^,str.Length(buffer^));
IF resultStr = NIL THEN
result := noMemory;
ELSIF result > 0 THEN
result := rls.SetRC0(msg);
ELSE
result := rls.SetRC5(msg);
END;
END;
DISPOSE(buffer);
RETURN result;
END ParsePattern;
(* ---------------------------------------------------------------- *)
(****** rexxdossupport.library/Delete *******************
*
* NAME
* Delete -- Delete a file or directory (V2)
*
* SYNOPSIS
* success = Delete( name )
*
* FUNCTION
* This attempts to delete the file or directory specified by
* 'name'. If the deletion fails an error is returned and the
* rexx variable RC is set. Note that all the files within a
* directory must be deleted before the directory itself can be
* deleted.
*
* INPUTS
* name - name of file or directory to delete.
*
* RESULT
* success - If TRUE, the file was sucessfully deleted,
* FALSE indicates failure.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* SEE ALSO
* Fault(), dos.library/DeleteFile()
*
****************************)
PROCEDURE Delete (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
CONST
argName = 1;
VAR
retval: INTEGER;
BEGIN
IF msg.args[argName] = NIL THEN RETURN invalidArg; END;
retval := rx.ok;
IF d.DeleteFile(msg.args[argName]^) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
END;
IF resultStr = NIL THEN retval := noMemory; END;
RETURN retval;
END Delete;
(****** rexxdossupport.library/Rename *******************
*
* NAME
* Rename -- Rename a directory or file (V2)
*
* SYNOPSIS
* success = Rename( oldName, newName )
*
* FUNCTION
* Rename() attempts to rename the file or directory specified
* as 'oldName' with the name 'newName'. If the file or
* directory 'newName' exists, Rename() fails and returns an
* error. Both 'oldName' and the 'newName' can contain a
* directory specification. In this case, the file will be moved
* from one directory to another.
*
* Note: it is impossible to Rename() a file from one volume to
* another.
*
* INPUTS
* oldName - pointer to a null-terminated string
* newName - pointer to a null-terminated string
*
* RESULT
* success - If TRUE, the variable was sucessfully deleted,
* FALSE indicates failure.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* SEE ALSO
* Fault(), dos.library/Rename()
*
***************************)
PROCEDURE Rename (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
retval: INTEGER;
CONST
argFrom = 1; argTo = 2;
BEGIN
IF ~ rls.ArgsPresent(msg,argFrom,argTo) THEN RETURN invalidArg; END;
retval := rx.ok;
IF d.Rename(msg.args[argFrom]^, msg.args[argTo]^) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
END;
IF resultStr = NIL THEN retval := noMemory; END;
RETURN retval;
END Rename;
(****** rexxdossupport.library/MakeDir *******************
*
* NAME
* MakeDir -- Create a new directory (V2)
*
* SYNOPSIS
* success = MakeDir( name )
*
* FUNCTION
* MakeDir creates a new directory with the specified name. If
* it fails an error is returned and the rexx variable RC is
* set. Directories can only be created on devices which
* support them, e.g. disks.
*
* INPUTS
* name - name of directory to create
*
* RESULT
* success - If TRUE, the variable was sucessfully deleted,
* FALSE indicates failure.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* SEE ALSO
* Fault(), dos.library/CreateDir()
*
**************************)
PROCEDURE MakeDir (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
retval: INTEGER;
CONST
argName = 1;
VAR
dir: d.FileLockPtr;
BEGIN
IF msg.args[argName] = NIL THEN RETURN invalidArg; END;
retval := rx.ok;
dir := d.CreateDir(msg.args[argName]^);
IF dir # NIL THEN
d.UnLock(dir);
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
END;
IF resultStr = NIL THEN retval := noMemory; END;
RETURN retval;
END MakeDir;
(****** rexxdossupport.library/SetComment *******************
*
* NAME
* SetComment -- Change a files' comment string (V2)
*
* SYNOPSIS
* success = SetComment( name, comment )
*
* FUNCTION
* SetComment() sets a comment on a file or directory. The
* comment may be up to 80 characters in the current ROM
* filesystem (and RAM:). Note that not all filesystems will
* support comments (for example, NFS usually will not), or the
* size of comment supported may vary.
*
* INPUTS
* name - name of file or directory to set comment
* comment - comment to be set
*
* RESULT
* success - If TRUE, the variable was sucessfully deleted,
* FALSE indicates failure.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* SEE ALSO
* SetProtection(), Fault(), dos.library/SetComment()
*
**************************)
PROCEDURE SetComment (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
retval: INTEGER;
CONST
argFile = 1; argComment = 2;
BEGIN
IF ~ rls.ArgsPresent(msg,argFile,argComment) THEN RETURN invalidArg; END;
retval := rx.ok;
IF d.SetComment(msg.args[argFile]^, msg.args[argComment]^) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
END;
IF resultStr = NIL THEN retval := noMemory; END;
RETURN retval;
END SetComment;
(****** rexxdossupport.library/SetProtection *******************
*
* NAME
* SetProtection -- Set protection for a file or directory (V2)
*
* SYNOPSIS
* success = SetProtection( name, mask )
*
* FUNCTION
* SetProtection() sets the protection attributes on a file or
* directory. See <dos/dos.h> for a listing of protection bits.
*
* The archive bit should be cleared by the filesystem whenever
* the file is changed. Backup utilities will generally set the
* bit after backing up each file.
*
* The V36 Shell looks at the execute bit, and will refuse to
* execute a file if it is set.
*
* Other bits will be defined in the <dos/dos.h>include files.
* Rather than referring to bits by number you should use the
* definitions in <dos/dos.h>.
*
* INPUTS
* name - name of file or directory to set protection
* mask - the protection mask required
*
* RESULT
* success - If TRUE, the variable was sucessfully deleted,
* FALSE indicates failure.
*
* RC (rexx variable) - contains the dos error code if the
* function was not successfull. This can can directly
* be used as input for Fault().
*
* SEE ALSO
* SetComment(), Fault(), dos.library/SetProtection()
*
**************************)
PROCEDURE SetProtection (msg: rx.RexxMsgPtr; VAR resultStr: e.LSTRPTR): INTEGER;
VAR
retval: INTEGER;
CONST
argFile = 1; argFlags = 2;
TYPE
LONGSETPtr = UNTRACED POINTER TO LONGSET;
BEGIN
IF ~ rls.ArgsPresent(msg,argFile,argFlags)
OR (rxs.LengthArgstring(msg.args[argFlags]) # 4)
THEN RETURN invalidArg; END;
retval := rx.ok;
IF d.SetProtection(msg.args[argFile]^,y.VAL(LONGSETPtr,msg.args[argFile])^) THEN
resultStr := rxs.CreateArgstring(strTRUE,1);
ELSE
resultStr := rxs.CreateArgstring(strFALSE,1);
retval := rls.SetRC(msg,d.IoErr());
END;
IF resultStr = NIL THEN retval := noMemory; END;
RETURN retval;
END SetProtection;
(* ---------------------------------------------------------------- *)
PROCEDURE Dispatch * (msg{8}: rx.RexxMsgPtr): LONGINT; (* $SaveRegs+ *)
VAR
resultStr: e.LSTRPTR;
retval: LONGINT;
BEGIN
ol.SetA5();
retval := rls.Dispatch(msg,resultStr,functionList);
y.SETREG(8,resultStr);
RETURN retval;
END Dispatch;
BEGIN
IF (rxs.base = NIL) OR (d.base.lib.version < 37) THEN HALT(20); END;
END rexxdossupport.